home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / tpu-extras.el.z / tpu-extras.el
Encoding:
Text File  |  1998-10-28  |  16.7 KB  |  478 lines
  1. ;;; tpu-extras.el --- Scroll margins and free cursor mode for TPU-edt
  2.  
  3. ;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Rob Riepel <riepel@networking.stanford.edu>
  6. ;; Maintainer: Rob Riepel <riepel@networking.stanford.edu>
  7. ;; Keywords: emulations
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; GNU Emacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Commentary:
  27.  
  28. ;;  Use the functions defined here to customize TPU-edt to your tastes by
  29. ;;  setting scroll margins and/or turning on free cursor mode.  Here's an
  30. ;;  example for your .emacs file.
  31.  
  32. ;;     (tpu-set-cursor-free)                   ; Set cursor free.
  33. ;;     (tpu-set-scroll-margins "10%" "15%")    ; Set scroll margins.
  34.  
  35. ;;  Scroll margins and cursor binding can be changed from within emacs using
  36. ;;  the following commands:
  37.  
  38. ;;     tpu-set-scroll-margins  or   set scroll margins
  39. ;;     tpu-set-cursor-bound    or   set cursor bound
  40. ;;     tpu-set-cursor-free     or   set cursor free
  41.  
  42. ;;  Additionally, Gold-F toggles between bound and free cursor modes.
  43.  
  44. ;;  Note that switching out of free cursor mode or exiting TPU-edt while in
  45. ;;  free cursor mode strips trailing whitespace from every line in the file.
  46.  
  47.  
  48. ;;; Details:
  49.  
  50. ;;  The functions contained in this file implement scroll margins and free
  51. ;;  cursor mode.  The following keys and commands are affected.
  52.  
  53. ;;       key/command   function                        scroll   cursor
  54.  
  55. ;;       Up-Arrow      previous line                     x        x
  56. ;;       Down-Arrow    next line                         x        x
  57. ;;       Right-Arrow   next character                             x
  58. ;;       Left-Arrow    previous character                         x
  59. ;;       KP0           next or previous line             x
  60. ;;       KP7           next or previous page             x
  61. ;;       KP8           next or previous screen           x
  62. ;;       KP2           next or previous end-of-line      x        x
  63. ;;       Control-e     current end-of-line                        x
  64. ;;       Control-h     previous beginning-of-line        x
  65. ;;       Next Scr      next screen                       x
  66. ;;       Prev Scr      previous screen                   x
  67. ;;       Search        find a string                     x
  68. ;;       Replace       find and replace a string         x
  69. ;;       Newline       insert a newline                  x
  70. ;;       Paragraph     next or previous paragraph        x
  71. ;;       Auto-Fill     break lines on spaces             x
  72.  
  73. ;;  These functions are not part of the base TPU-edt for the following
  74. ;;  reasons:
  75.  
  76. ;;  Free cursor mode is implemented with the emacs picture-mode functions.
  77. ;;  These functions support moving the cursor all over the screen, however,
  78. ;;  when the cursor is moved past the end of a line, spaces or tabs are
  79. ;;  appended to the line - even if no text is entered in that area.  In
  80. ;;  order for a free cursor mode to work exactly like TPU/edt, this trailing
  81. ;;  whitespace needs to be dealt with in every function that might encounter
  82. ;;  it.  Such global changes are impractical, however, free cursor mode is
  83. ;;  too valuable to abandon completely, so it has been implemented in those
  84. ;;  functions where it serves best.
  85.  
  86. ;;  The implementation of scroll margins adds overhead to previously
  87. ;;  simple and often used commands.  These commands are now responsible
  88. ;;  for their normal operation and part of the display function.  There
  89. ;;  is a possibility that this display overhead could adversely affect the
  90. ;;  performance of TPU-edt on slower computers.  In order to support the
  91. ;;  widest range of computers, scroll margin support is optional.
  92.  
  93. ;;  It's actually not known whether the overhead associated with scroll
  94. ;;  margin support is significant.  If you find that it is, please send
  95. ;;  a note describing the extent of the performance degradation.  Be sure
  96. ;;  to include a description of the platform where you're running TPU-edt.
  97. ;;  Send your note to the address provided by Gold-V.
  98.  
  99. ;;  Even with these differences and limitations, these functions implement
  100. ;;  important aspects of the real TPU/edt.  Those who miss free cursor mode
  101. ;;  and/or scroll margins will appreciate these implementations.
  102.  
  103. ;;; Code:
  104.  
  105.  
  106. ;;;  Gotta have tpu-edt
  107.  
  108. (require 'tpu-edt)
  109.  
  110.  
  111. ;;;  Customization variables
  112.  
  113. (defconst tpu-top-scroll-margin 0
  114.   "*Scroll margin at the top of the screen.
  115. Interpreted as a percent of the current window size.")
  116. (defconst tpu-bottom-scroll-margin 0
  117.   "*Scroll margin at the bottom of the screen.
  118. Interpreted as a percent of the current window size.")
  119.  
  120. (defvar tpu-backward-char-like-tpu t
  121.   "*If non-nil, in free cursor mode backward-char (left-arrow) works
  122. just like TPU/edt.  Otherwise, backward-char will move to the end of
  123. the previous line when starting from a line beginning.")
  124.  
  125.  
  126. ;;;  Global variables
  127.  
  128. (defvar tpu-cursor-free nil
  129.   "If non-nil, let the cursor roam free.")
  130.  
  131.  
  132. ;;;  Hooks  --  Set cursor free in picture mode.
  133. ;;;             Clean up when writing a file from cursor free mode.
  134.  
  135. (add-hook 'picture-mode-hook 'tpu-set-cursor-free)
  136.  
  137. (defun tpu-write-file-hook nil
  138.   "Eliminate whitespace at ends of lines, if the cursor is free."
  139.   (if (and (buffer-modified-p) tpu-cursor-free) (picture-clean)))
  140.  
  141. (or (memq 'tpu-write-file-hook write-file-hooks)
  142.     (setq write-file-hooks
  143.       (cons 'tpu-write-file-hook write-file-hooks)))
  144.  
  145.  
  146. ;;;  Utility routines for implementing scroll margins
  147.  
  148. (defun tpu-top-check (beg lines)
  149.   "Enforce scroll margin at the top of screen."
  150.   (let ((margin     (/ (* (window-height) tpu-top-scroll-margin) 100)))
  151.     (cond ((< beg margin) (recenter beg))
  152.       ((< (- beg lines) margin) (recenter margin)))))
  153.  
  154. (defun tpu-bottom-check (beg lines)
  155.   "Enforce scroll margin at the bottom of screen."
  156.   (let* ((height (window-height))
  157.      (margin (+ 1 (/ (* height tpu-bottom-scroll-margin) 100)))
  158.      ;; subtract 1 from height because it includes mode line
  159.      (difference (- height margin 1)))
  160.     (cond ((> beg difference) (recenter beg))
  161.       ((> (+ beg lines) difference) (recenter (- margin))))))
  162.  
  163.  
  164. ;;;  Movement by character
  165.  
  166. (defun tpu-forward-char (num)
  167.   "Move right ARG characters (left if ARG is negative)."
  168.   (interactive "p")
  169.   (if tpu-cursor-free (picture-forward-column num) (forward-char num)))
  170.  
  171. (defun tpu-backward-char (num)
  172.   "Move left ARG characters (right if ARG is negative)."
  173.   (interactive "p")
  174.   (cond ((not tpu-cursor-free)
  175.      (backward-char num))
  176.     (tpu-backward-char-like-tpu
  177.      (picture-backward-column num))
  178.     ((bolp)
  179.      (backward-char 1)
  180.      (picture-end-of-line)
  181.      (picture-backward-column (1- num)))
  182.     (t
  183.      (picture-backward-column num))))
  184.  
  185.  
  186. ;;;  Movement by line
  187.  
  188. (defun tpu-next-line (num)
  189.   "Move to next line.
  190. Prefix argument serves as a repeat count."
  191.   (interactive "p")
  192.   (let ((beg (tpu-current-line)))
  193.     (if tpu-cursor-free (or (eobp) (picture-move-down num))
  194.       (next-line-internal num))
  195.     (tpu-bottom-check beg num)
  196.     (setq this-command 'next-line)))
  197.  
  198. (defun tpu-previous-line (num)
  199.   "Move to previous line.
  200. Prefix argument serves as a repeat count."
  201.   (interactive "p")
  202.   (let ((beg (tpu-current-line)))
  203.     (if tpu-cursor-free (picture-move-up num) (next-line-internal (- num)))
  204.     (tpu-top-check beg num)
  205.     (setq this-command 'previous-line)))
  206.  
  207. (defun tpu-next-beginning-of-line (num)
  208.   "Move to beginning of line; if at beginning, move to beginning of next line.
  209. Accepts a prefix argument for the number of lines to move."
  210.   (interactive "p")
  211.   (let ((beg (tpu-current-line)))
  212.     (backward-char 1)
  213.     (forward-line (- 1 num))
  214.     (tpu-top-check beg num)))
  215.  
  216. (defun tpu-next-end-of-line (num)
  217.   "Move to end of line; if at end, move to end of next line.
  218. Accepts a prefix argument for the number of lines to move."
  219.   (interactive "p")
  220.   (let ((beg (tpu-current-line)))
  221.     (cond (tpu-cursor-free
  222.        (let ((beg (point)))
  223.          (if (< 1 num) (forward-line num))
  224.          (picture-end-of-line)
  225.          (if (<= (point) beg) (progn (forward-line) (picture-end-of-line)))))
  226.       (t
  227.        (forward-char)
  228.        (end-of-line num)))
  229.     (tpu-bottom-check beg num)))
  230.  
  231. (defun tpu-previous-end-of-line (num)
  232.   "Move EOL upward.
  233. Accepts a prefix argument for the number of lines to move."
  234.   (interactive "p")
  235.   (let ((beg (tpu-current-line)))
  236.     (cond (tpu-cursor-free
  237.        (picture-end-of-line (- 1 num)))
  238.       (t
  239.        (end-of-line (- 1 num))))
  240.     (tpu-top-check beg num)))
  241.  
  242. (defun tpu-current-end-of-line nil
  243.   "Move point to end of current line."
  244.   (interactive)
  245.   (let ((beg (point)))
  246.     (if tpu-cursor-free (picture-end-of-line) (end-of-line))
  247.     (if (= beg (point)) (message "You are already at the end of a line."))))
  248.  
  249. (defun tpu-forward-line (num)
  250.   "Move to beginning of next line.
  251. Prefix argument serves as a repeat count."
  252.   (interactive "p")
  253.   (let ((beg (tpu-current-line)))
  254.     (next-line-internal num)
  255.     (tpu-bottom-check beg num)
  256.     (beginning-of-line)))
  257.  
  258. (defun tpu-backward-line (num)
  259.   "Move to beginning of previous line.
  260. Prefix argument serves as repeat count."
  261.   (interactive "p")
  262.   (let ((beg (tpu-current-line)))
  263.     (or (bolp) (>= 0 num) (setq num (- num 1)))
  264.     (next-line-internal (- num))
  265.     (tpu-top-check beg num)
  266.     (beginning-of-line)))
  267.  
  268.  
  269. ;;;  Movement by paragraph
  270.  
  271. (defun tpu-paragraph (num)
  272.   "Move to the next paragraph in the current direction.
  273. A repeat count means move that many paragraphs."
  274.   (interactive "p")
  275.   (let* ((left nil)
  276.      (beg (tpu-current-line))
  277.      (height (window-height))
  278.      (top-percent
  279.       (if (= 0 tpu-top-scroll-margin) 10 tpu-top-scroll-margin))
  280.      (bottom-percent
  281.       (if (= 0 tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin))
  282.      (top-margin (/ (* height top-percent) 100))
  283.      (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
  284.      (bottom-margin (max beg (- height bottom-up-margin 1)))
  285.      (top (save-excursion (move-to-window-line top-margin) (point)))
  286.      (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
  287.      (far (save-excursion
  288.         (goto-char bottom) (forward-line (- height 2)) (point))))
  289.     (cond (tpu-advance
  290.        (tpu-next-paragraph num)
  291.        (cond((> (point) far)
  292.          (setq left (save-excursion (forward-line height)))
  293.          (if (= 0 left) (recenter top-margin)
  294.            (recenter (- left bottom-up-margin))))
  295.         (t
  296.          (and (> (point) bottom) (recenter bottom-margin)))))
  297.       (t
  298.        (tpu-previous-paragraph num)
  299.        (and (< (point) top) (recenter (min beg top-margin)))))))
  300.  
  301.  
  302. ;;;  Movement by page
  303.  
  304. (defun tpu-page (num)
  305.   "Move to the next page in the current direction.
  306. A repeat count means move that many pages."
  307.   (interactive "p")
  308.   (let* ((left nil)
  309.      (beg (tpu-current-line))
  310.      (height (window-height))
  311.      (top-percent
  312.       (if (= 0 tpu-top-scroll-margin) 10 tpu-top-scroll-margin))
  313.      (bottom-percent
  314.       (if (= 0 tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin))
  315.      (top-margin (/ (* height top-percent) 100))
  316.      (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
  317.      (bottom-margin (max beg (- height bottom-up-margin 1)))
  318.      (top (save-excursion (move-to-window-line top-margin) (point)))
  319.      (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
  320.      (far (save-excursion
  321.         (goto-char bottom) (forward-line (- height 2)) (point))))
  322.     (cond (tpu-advance
  323.        (forward-page num)
  324.        (cond((> (point) far)
  325.          (setq left (save-excursion (forward-line height)))
  326.          (if (= 0 left) (recenter top-margin)
  327.            (recenter (- left bottom-up-margin))))
  328.         (t
  329.          (and (> (point) bottom) (recenter bottom-margin)))))
  330.       (t
  331.        (backward-page num)
  332.        (and (< (point) top) (recenter (min beg top-margin)))))))
  333.  
  334.  
  335. ;;;  Scrolling
  336.  
  337. (defun tpu-scroll-window-down (num)
  338.   "Scroll the display down to the next section.
  339. A repeat count means scroll that many sections."
  340.   (interactive "p")
  341.   (let* ((beg (tpu-current-line))
  342.      (height (1- (window-height)))
  343.      (lines (* num (/ (* height tpu-percent-scroll) 100))))
  344.     (next-line-internal (- lines))
  345.     (tpu-top-check beg lines)))
  346.  
  347. (defun tpu-scroll-window-up (num)
  348.   "Scroll the display up to the next section.
  349. A repeat count means scroll that many sections."
  350.   (interactive "p")
  351.   (let* ((beg (tpu-current-line))
  352.      (height (1- (window-height)))
  353.      (lines (* num (/ (* height tpu-percent-scroll) 100))))
  354.     (next-line-internal lines)
  355.     (tpu-bottom-check beg lines)))
  356.  
  357.  
  358. ;;;  Replace the TPU-edt internal search function
  359.  
  360. (defun tpu-search-internal (pat &optional quiet)
  361.   "Search for a string or regular expression."
  362.   (let* ((left nil)
  363.      (beg (tpu-current-line))
  364.      (height (window-height))
  365.      (top-percent
  366.       (if (= 0 tpu-top-scroll-margin) 10 tpu-top-scroll-margin))
  367.      (bottom-percent
  368.       (if (= 0 tpu-bottom-scroll-margin) 15 tpu-bottom-scroll-margin))
  369.      (top-margin (/ (* height top-percent) 100))
  370.      (bottom-up-margin (+ 1 (/ (* height bottom-percent) 100)))
  371.      (bottom-margin (max beg (- height bottom-up-margin 1)))
  372.      (top (save-excursion (move-to-window-line top-margin) (point)))
  373.      (bottom (save-excursion (move-to-window-line bottom-margin) (point)))
  374.      (far (save-excursion
  375.         (goto-char bottom) (forward-line (- height 2)) (point))))
  376.     (tpu-search-internal-core pat quiet)
  377.     (if tpu-searching-forward
  378.     (cond((> (point) far)
  379.           (setq left (save-excursion (forward-line height)))
  380.           (if (= 0 left) (recenter top-margin)
  381.         (recenter (- left bottom-up-margin))))
  382.          (t
  383.           (and (> (point) bottom) (recenter bottom-margin))))
  384.       (and (< (point) top) (recenter (min beg top-margin))))))
  385.  
  386.  
  387.  
  388. ;;;  Replace the newline, newline-and-indent, and do-auto-fill functions
  389.  
  390. (or (fboundp 'tpu-old-newline)
  391.     (fset 'tpu-old-newline (symbol-function 'newline)))
  392. (or (fboundp 'tpu-old-do-auto-fill)
  393.     (fset 'tpu-old-do-auto-fill (symbol-function 'do-auto-fill)))
  394. (or (fboundp 'tpu-old-newline-and-indent)
  395.     (fset 'tpu-old-newline-and-indent (symbol-function 'newline-and-indent)))
  396.  
  397. (defun newline (&optional num)
  398.   "Insert a newline.  With arg, insert that many newlines.
  399. In Auto Fill mode, can break the preceding line if no numeric arg.
  400. This is the TPU-edt version that respects the bottom scroll margin."
  401.   (interactive "p")
  402.   (let ((beg (tpu-current-line)))
  403.     (or num (setq num 1))
  404.     (tpu-old-newline num)
  405.     (tpu-bottom-check beg num)))
  406.  
  407. (defun newline-and-indent nil
  408.   "Insert a newline, then indent according to major mode.
  409. Indentation is done using the current indent-line-function.
  410. In programming language modes, this is the same as TAB.
  411. In some text modes, where TAB inserts a tab, this indents
  412. to the specified left-margin column.  This is the TPU-edt
  413. version that respects the bottom scroll margin."
  414.   (interactive)
  415.   (let ((beg (tpu-current-line)))
  416.     (tpu-old-newline-and-indent)
  417.     (tpu-bottom-check beg 1)))
  418.  
  419. (defun do-auto-fill nil
  420.   "TPU-edt version that respects the bottom scroll margin."
  421.   (let ((beg (tpu-current-line)))
  422.     (tpu-old-do-auto-fill)
  423.     (tpu-bottom-check beg 1)))
  424.  
  425.  
  426. ;;;  Function to set scroll margins
  427.  
  428. ;;;###autoload
  429. (defun tpu-set-scroll-margins (top bottom)
  430.   "Set scroll margins."
  431.   (interactive
  432.    "sEnter top scroll margin (N lines or N%% or RETURN for current value): \
  433. \nsEnter bottom scroll margin (N lines or N%% or RETURN for current value): ")
  434.   ;; set top scroll margin
  435.   (or (string= top "")
  436.       (if (string= "%" (substring top -1))
  437.       (setq tpu-top-scroll-margin (string-to-int top))
  438.     (setq tpu-top-scroll-margin
  439.           (/ (1- (+ (* (string-to-int top) 100) (window-height)))
  440.          (window-height)))))
  441.   ;; set bottom scroll margin
  442.   (or (string= bottom "")
  443.       (if (string= "%" (substring bottom -1))
  444.       (setq tpu-bottom-scroll-margin (string-to-int bottom))
  445.     (setq tpu-bottom-scroll-margin
  446.           (/ (1- (+ (* (string-to-int bottom) 100) (window-height)))
  447.          (window-height)))))
  448.   ;; report scroll margin settings if running interactively
  449.   (and (interactive-p)
  450.        (message "Scroll margins set.  Top = %s%%, Bottom = %s%%"
  451.         tpu-top-scroll-margin tpu-bottom-scroll-margin)))
  452.  
  453.  
  454. ;;;  Functions to set cursor bound or free
  455.  
  456. ;;;###autoload
  457. (defun tpu-set-cursor-free nil
  458.   "Allow the cursor to move freely about the screen."
  459.   (interactive)
  460.   (setq tpu-cursor-free t)
  461.   (substitute-key-definition 'tpu-set-cursor-free
  462.                  'tpu-set-cursor-bound
  463.                  GOLD-map)
  464.   (message "The cursor will now move freely about the screen."))
  465.  
  466. ;;;###autoload
  467. (defun tpu-set-cursor-bound nil
  468.   "Constrain the cursor to the flow of the text."
  469.   (interactive)
  470.   (picture-clean)
  471.   (setq tpu-cursor-free nil)
  472.   (substitute-key-definition 'tpu-set-cursor-bound
  473.                  'tpu-set-cursor-free
  474.                  GOLD-map)
  475.   (message "The cursor is now bound to the flow of your text."))
  476.  
  477. ;;; tpu-extras.el ends here
  478.